home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Night Owl 6
/
Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso
/
025a
/
gsdb25.zip
/
GS_STRNG.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-07-28
|
12KB
|
335 lines
unit GS_Strng;
{-----------------------------------------------------------------------------
Changes:
13 Apr 91 - Added function Strip_Flip. This function will remove
trailing spaces and move any part of the string that
is preceeded by a '~' to the end of the string.
For Example:
Smith~John X.
will be converted to:
John X. Smith
on return.
This is ideal for maintaining a name alphabetically
while allowing a simple function to make the name
'normal' on display.
02 May 91 - Converted StrDate to accept a longint and convert to the
MM/DD/YY string format. The longint value is the julian
date (for example, 1 Jan 90 has a julian date of 2447893)
Added a ValDate function to convert a date string of
either MM/DD/YY or YYYYMMDD to the longint juilian day.
------------------------------------------------------------------------------}
interface
uses
Crt,
Dos,
GS_Date;
function AllCaps(var t : string) : string;
procedure CnvAscToStr(var asc, st; lth : integer);
procedure CnvStrToAsc(var st, asc; lth : integer);
function Strip_Flip(st : string) : string;
function StrDate(jul : longint) : string;
function StrNumber(num : real; lth,dec : integer) : string;
function StrLogic(tf : boolean) : string;
function SubStr(s : string; b,l : integer) : string;
function TrimL(strn : string):string; {Deletes leading spaces}
function TrimR(strn : string):string; {Deletes trailing spaces}
function Unique_Field : string; {Used to create a unique 8-byte string}
function ValDate(strn : string) : longint;
function ValNumber(strn : string) : real;
function ValLogic(strn : string) : boolean;
implementation
function AllCaps(var t : string) : string;
var
i : integer;
s : string;
begin
s := t;
for i := 1 to length(s) do s[i] := upcase(s[i]);
AllCaps := s;
end;
procedure CnvAscToStr(var asc, st; lth : integer);
var
a : array[0..255] of byte absolute asc;
s : string[255] absolute st;
i : integer;
begin
move(a,s[1],lth);
s[0] := chr(lth);
i := pos(#0,s);
if i > 0 then dec(i)
else if a[0] <> 0 then i := lth;
s[0] := chr(i);
end;
procedure CnvStrToAsc(var st, asc; lth : integer);
var
a : array[0..255] of byte absolute asc;
s : string[255] absolute st;
t : string;
i : integer;
begin
t := s;
FillChar(a,lth,#0);
i := length(t);
if i >= lth then i := lth;
move(t[1],a,i);
end;
Function Strip_Flip(st : string) : string;
var
wst,
wstl : string;
i : integer;
begin
wst := TrimR(st);
wst := wst + ' ';
i := pos('~', wst);
if i <> 0 then
begin
wstl := substr(wst,1,pred(i));
system.delete(wst,1,i);
wst := wst + wstl;
end;
Strip_Flip := wst;
end;
function StrDate(jul : longint) : string;
begin
StrDate := GS_Date_View(jul);
end;
function StrNumber(num : real; lth,dec : integer) : string;
var
s : string;
begin
Str(num:lth:dec,s);
StrNumber := s;
end;
function StrLogic(tf : boolean) : string;
begin
if tf then StrLogic := 'T' else StrLogic := 'F';
end;
{.pa}
{
SUBSTR
╔══════════════════════════════════════════════════════════════════╗
║ ║
║ The SUBSTR function extracts a substring from a string. ║
║ ║
║ Calling the Method: ║
║ ║
║ x := SubStr(s,b,l) ║
║ ║
║ ( where x is the string to be trimmed. ║
║ s is of type string. ║
║ b is the integer start of substring. ║
║ l is the integer length of substring. ║
║ ║
║ ║
║ Result: ║
║ ║
║ A substring of l positions beginning at b is returned. ║
║ ║
╚══════════════════════════════════════════════════════════════════╝
}
Function SubStr(s : string; b,l : integer) : string;
var
st : string;
i : integer;
begin
st := '';
if b < 0 then b := 1;
st := copy(s, b, l);
SubStr := st;
end;
{.pa}
{
TRIML
╔══════════════════════════════════════════════════════════════════╗
║ ║
║ The TRIML function removes leading spaces from a field. ║
║ ║
║ Calling the Method: ║
║ ║
║ d := TrimL(x) ║
║ ║
║ ( where x is the string to be trimmed. ║
║ d is of type string. ║
║ ║
║ Result: ║
║ ║
║ Leading spaces are removed and the field returned. ║
║ ║
╚══════════════════════════════════════════════════════════════════╝
}
function TrimL(strn : string) : string;
var
st : string;
begin
st := strn; {Load work string}
while (length(st) > 0) and (st[1] = ' ') do delete(st, 1, 1);
{Loop to delete leading spaces}
TrimL := st; {Return trimmed string}
end;
{.pa}
{
TRIMR
╔══════════════════════════════════════════════════════════════════╗
║ ║
║ The TRIMR function removes trailing spaces from a field. ║
║ ║
║ Calling the Method: ║
║ ║
║ d := TrimR(x) ║
║ ║
║ ( where x is the string to be trimmed. ║
║ d is of type string. ║
║ ║
║ Result: ║
║ ║
║ Trailing spaces are removed and the field returned. ║
║ ║
╚══════════════════════════════════════════════════════════════════╝
}
function TrimR(strn : string) : string;
var
l : integer;
st : string;
begin
st := strn; {Load work string}
l := length(st); {Load string length}
st[0] := '*'; {Ensure string length is not decimal 32,}
{which is an ASCII space}
while st[l] = ' ' do dec(l); {Loop searching down to first non-blank}
st[0] := chr(l); {Set string to new length}
TrimR := st; {Return trimmed length}
end;
{.pa}
{
UNIQUE_FIELD
╔══════════════════════════════════════════════════════════════════╗
║ ║
║ The UNIQUE-FIELD function creates an eight-character unique ║
║ value which may be used as a unique field for a database ║
║ record. The value is based on the data and time of the ║
║ function call, and is down to hundredths of a second. Thus, ║
║ each value returned will be unique. ║
║ ║
║ Calling the Method: ║
║ ║
║ d := Unique_Field ║
║ ║
║ ( where d is a string of length 8. ║
║ ║
║ Result: ║
║ ║
║ An 8-byte unique string of characters is returned. ║
║ ║
╚══════════════════════════════════════════════════════════════════╝
}
function Unique_Field : string;
var
y, mo, d, dow : Word;
h, mn, s, hund : Word;
LS,
LM : string;
{
┌─────────────────────────────────────┐
│ Convert a number to a character. │
│ Uses the ASCII characters starting │
│ at ASCII 64 │
└─────────────────────────────────────┘
}
function LZ(w : Word) : String;
begin
LZ := chr(w+64);
end;
{
┌──────────────────────────────────────┐
│ Beginning of Unique_Field function │
└──────────────────────────────────────┘
}
begin
GetDate(y,mo,d,dow); {Call TP 5.5 procedure for current date}
LS := LZ(y mod 10)+LZ(mo)+LZ(d); {Convert last digit of year, month, and}
{day to three individual ASCII characters}
{and concatenate}
GetTime(h,mn,s,hund); {Call TP 5.5 procedure for current time}
LS := LS+LZ(h)+LZ(mn)+LZ(s)+LZ(hund div 10)+LZ(hund mod 10);
{Convert hour, minute, second, and the}
{tens and units digits of the hundredths}
{of seconds to individual ASCII digits}
{and concatenate with the date string}
delay(100); {Delay to ensure next call will retrieve}
{an unique time stamp}
Unique_Field := LS; {Return the unique field}
end;
function ValDate(strn : string) : longint;
var
v : longint;
begin
v := GS_Date_Juln(strn);
if v > 0 then ValDate := v else ValDate := 0;
end;
function ValNumber(strn : string) : real;
var
r : integer;
n : real;
begin
val(strn,n,r);
if r <> 0 then ValNumber := 0
else ValNumber := n;
end;
function ValLogic(strn : string) : boolean;
var
c : char;
begin
if strn[0] <> #1 then ValLogic := false
else
begin
c := strn[1];
if c in ['T','t','Y','y'] then ValLogic := true
else ValLogic := false;
end;
end;
end.
